home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xm / list < prev    next >
Encoding:
Text File  |  1991-09-26  |  2.8 KB  |  98 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; List widget demo (directory browser) for Motif
  4.  
  5. (require 'motif)
  6. (load-widgets shell form label push-button list)
  7. (require 'unix 'unix.o)
  8. (require 'sort 'qsort)
  9.  
  10. (define top (application-initialize 'list))
  11. (set-values! top 'allow-shell-resize #t)
  12.  
  13. (define form (create-managed-widget (find-class 'form) top))
  14.  
  15. (define quit (create-managed-widget (find-class 'push-button) form))
  16. (set-values! quit 'left-attachment "ATTACH_FORM"
  17.               'top-attachment "ATTACH_FORM"
  18.           'width 50
  19.           'height 30
  20.           'border-width 1
  21.           'label-string "quit")
  22.  
  23. (add-callback quit 'activate-callback (lambda x (destroy-widget top) 
  24.                        (exit)))
  25.  
  26. (define back (create-managed-widget (find-class 'push-button) form))
  27. (set-values! back 'left-attachment "ATTACH_WIDGET"
  28.               'left-widget quit
  29.           'top-attachment "ATTACH_FORM"
  30.           'width 50
  31.           'height 30
  32.           'border-width 1
  33.           'label-string "back")
  34.  
  35. (add-callback back 'activate-callback (lambda x (goto "..")))
  36.  
  37. (define lab (create-managed-widget (find-class 'label) form))
  38. (set-values! lab 'border-width 0
  39.              'left-attachment "ATTACH_WIDGET"
  40.          'left-widget back
  41.          'top-attachment "ATTACH_FORM"
  42.          'right-attachment "ATTACH_FORM"
  43.          'right-offset 4
  44.          'top-offset 4
  45.          'height 30
  46.          'recompute-size #t)
  47.  
  48. (define lst (create-managed-widget (find-class 'list) form ))
  49. (set-values! lst 'left-attachment "ATTACH_FORM"
  50.              'top-attachment "ATTACH_WIDGET"
  51.          'top-widget quit
  52.          'right-attachment "ATTACH_FORM"
  53.          'bottom-attachment "ATTACH_FORM"
  54.          'list-size-policy "VARIABLE"
  55.          'list-margin-width 5
  56.          'selection-policy "BROWSE_SELECT")
  57.  
  58. (add-callback lst 'browse-selection-callback
  59.           (lambda (w i)
  60.         (let ((stat (file-status (string-append
  61.                       where "/" (car (last-pair i))))))
  62.           (set-values! lab 'label-string stat)
  63.           (if (eq? stat 'directory)
  64.               (goto (car (last-pair i)))))))
  65.  
  66. (define (goto dir)
  67.   (if (string=? dir "..")
  68.       (begin
  69.     (if (not (string=? where "/"))
  70.         (begin
  71.               (set! where
  72.             (substring where 0
  73.                    (do ((i (- (string-length where) 2) (1- i)))
  74.                    ((char=? (string-ref where i) #\/) i))))
  75.               (if (eqv? where "")
  76.               (set! where "/")))))
  77.       (if (not (or (string=? dir "/") (string=? where "/")))
  78.       (set! where (string-append where "/")))
  79.       (set! where (string-append where dir)))
  80.   (set-values! lab 'label-string where)
  81.   (define l '())
  82.   (for-each (lambda (d) (if (not (member d '("." "..")))
  83.                 (set! l (cons d l))))
  84.         (read-directory where))
  85.   (if (null? l)
  86.       (set-values! lst 'items l 'item-count 0 'visible-item-count 1)
  87.       (set-values! lst 'items (sort l string<?) 'item-count (length l)
  88.                'visible-item-count (length l))))
  89.  
  90. (define where "")
  91.  
  92. (goto "/")
  93.  
  94. (set-values! lab 'label-string "Select directory:")
  95.  
  96. (realize-widget top)
  97. (context-main-loop (widget-context top))
  98.